home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 016a / gofer221.zip / MACHINE.C < prev    next >
C/C++ Source or Header  |  1991-11-20  |  33KB  |  1,188 lines
  1. /* --------------------------------------------------------------------------
  2.  * machine.c:    Copyright (c) Mark P Jones 1991.   All rights reserved.
  3.  *        See goferite.h for details and conditions of use etc...
  4.  *        Gofer version 2.21 November 1991
  5.  *
  6.  *        Last updated 08/11/91 mpj
  7.  *
  8.  * Graph reduction engine, code generation and execution
  9.  * ------------------------------------------------------------------------*/
  10.  
  11. #include "prelude.h"
  12. #include "storage.h"
  13. #include "connect.h"
  14. #include "errors.h"
  15. #include <setjmp.h>
  16.  
  17. /*#define DEBUG_RUN*/
  18. /*#define DEBUG_CODE*/
  19. Bool   andorOptimise = TRUE;        /* TRUE => optimise uses of &&, || */
  20. Bool   failOnError   = FALSE;        /* TRUE => abort as soon as error  */
  21.                     /*       occurs           */
  22.  
  23. /* --------------------------------------------------------------------------
  24.  * Data structures for machine memory (program storage):
  25.  * ------------------------------------------------------------------------*/
  26.  
  27. typedef enum {
  28.     iLOAD,   iCELL,   iCHAR,   iINT,   iFLOAT,
  29.     iSTRING, iMKAP,   iUPDATE, iUPDAP, iEVAL,
  30.     iRETURN, iINTGE,  iINTEQ,  iINTDV, iTEST,
  31.     iGOTO,   iSETSTK, iALLOC,  iSLIDE, iROOT,
  32.     iDICT,   iFAIL
  33. } Instr;
  34.  
  35. typedef Int Label;
  36.  
  37. typedef union {
  38.     Int   intVal;
  39.     Float floatVal;
  40.     Cell  cellVal;
  41.     Text  textVal;
  42.     Addr  addrVal;
  43.     Instr instrVal;
  44.     Label labVal;
  45. } MemCell;
  46.  
  47. typedef MemCell far *Memory;
  48. static    Memory        memory;
  49. #define intAt(m)    memory[m].intVal
  50. #define floatAt(m)  memory[m].floatVal
  51. #define cellAt(m)   memory[m].cellVal
  52. #define textAt(m)   memory[m].textVal
  53. #define addrAt(m)   memory[m].addrVal
  54. #define instrAt(m)  memory[m].instrVal
  55. #define labAt(m)    memory[m].labVal
  56.  
  57. /* --------------------------------------------------------------------------
  58.  * Local function prototypes:
  59.  * ------------------------------------------------------------------------*/
  60.  
  61. static Void  local instrNone    Args((Instr));
  62. static Void  local instrInt    Args((Instr,Int));
  63. static Void  local instrFloat   Args((Instr,FloatPro));
  64. static Void  local instrCell    Args((Instr,Cell));
  65. static Void  local instrText    Args((Instr,Text));
  66. static Void  local instrLab    Args((Instr,Label));
  67. static Void  local instrIntLab    Args((Instr,Int,Label));
  68. static Void  local instrCellLab Args((Instr,Cell,Label));
  69.  
  70. static Void  local asSTART    Args((Void));
  71. static Label local newLabel    Args((Label));
  72. static Void  local asEND    Args((Void));
  73. static Void  local asDICT    Args((Int));
  74. static Void  local asSLIDE    Args((Int));
  75. static Void  local asMKAP    Args((Int));
  76. static Void  local asUPDATE    Args((Int));
  77. static Void  local asGOTO    Args((Label));
  78.  
  79. #ifdef DEBUG_CODE
  80. static Void  local dissassemble Args((Addr,Addr));
  81. static Void  local printCell    Args((Cell));
  82. static Addr  local dissNone    Args((Addr,String));
  83. static Addr  local dissInt    Args((Addr,String));
  84. static Addr  local dissFloat    Args((Addr,String));
  85. static Addr  local dissCell    Args((Addr,String));
  86. static Addr  local dissText    Args((Addr,String));
  87. static Addr  local dissAddr    Args((Addr,String));
  88. static Addr  local dissIntAddr    Args((Addr,String));
  89. static Addr  local dissCellAddr Args((Addr,String));
  90. #endif
  91.  
  92. static Void  local build    Args((Cell,Int));
  93. static Void  local buildGuards    Args((List,Int));
  94. static Int   local buildLoc    Args((List,Int));
  95.  
  96. static Void  local make     Args((Cell,Int,Label,Label));
  97. static Void  local makeCond    Args((Cell,Cell,Cell,Int,Label,Label));
  98. static Void  local testGuard    Args((Pair,Int,Label,Label,Label));
  99. static Void  local testCase    Args((Pair,Int,Label,Label,Label));
  100.  
  101. static Void  local analyseAp    Args((Cell));
  102. static Void  local buildAp    Args((Cell,Int,Label,Bool));
  103.  
  104. static Void  local evalString   Args((Cell));
  105. static Void  local run        Args((Addr,StackPtr));
  106.  
  107. /* --------------------------------------------------------------------------
  108.  * Assembler: (Low level, instruction code storage)
  109.  * ------------------------------------------------------------------------*/
  110.  
  111. static Addr  startInstr;           /* first instruction after START    */
  112. static Addr  lastInstr;            /* last instr written (for peephole */
  113.                        /* optimisations etc.)           */
  114. static Addr  noMatch;               /* address of a single FAIL instr   */
  115.  
  116. static Void local instrNone(opc)       /* Opcode with no operands       */
  117. Instr opc; {
  118.     lastInstr           = getMem(1);
  119.     instrAt(lastInstr) = opc;
  120. }
  121.  
  122. static Void local instrInt(opc,n)      /* Opcode with integer operand       */
  123. Instr opc;
  124. Int   n; {
  125.     lastInstr           = getMem(2);
  126.     instrAt(lastInstr) = opc;
  127.     intAt(lastInstr+1) = n;
  128. }
  129.  
  130. static Void local instrFloat(opc,fl)   /* Opcode with Float operand        */
  131. Instr opc;
  132. Float fl; {
  133.     lastInstr            = getMem(2);
  134.     instrAt(lastInstr)   = opc;
  135.     floatAt(lastInstr+1) = fl;
  136. }
  137.  
  138. static Void local instrCell(opc,c)     /* Opcode with Cell operand       */
  139. Instr opc;
  140. Cell  c; {
  141.     lastInstr        = getMem(2);
  142.     instrAt(lastInstr)    = opc;
  143.     cellAt(lastInstr+1) = c;
  144. }
  145.  
  146. static Void local instrText(opc,t)     /* Opcode with Text operand       */
  147. Instr opc;
  148. Text  t; {
  149.     lastInstr        = getMem(2);
  150.     instrAt(lastInstr)    = opc;
  151.     textAt(lastInstr+1) = t;
  152. }
  153.  
  154. static Void local instrLab(opc,l)      /* Opcode with label operand       */
  155. Instr opc;
  156. Label l; {
  157.     lastInstr           = getMem(2);
  158.     instrAt(lastInstr) = opc;
  159.     labAt(lastInstr+1) = l;
  160.     if (l<0)
  161.     internal("bad Label");
  162. }
  163.  
  164. static Void local instrIntLab(opc,n,l) /* Opcode with int, label operands  */
  165. Instr opc;
  166. Int   n;
  167. Label l; {
  168.     lastInstr           = getMem(3);
  169.     instrAt(lastInstr) = opc;
  170.     intAt(lastInstr+1) = n;
  171.     labAt(lastInstr+2) = l;
  172.     if (l<0)
  173.     internal("bad Label");
  174. }
  175.  
  176. static Void local instrCellLab(opc,c,l)/* Opcode with cell, label operands */
  177. Instr opc;
  178. Cell  c;
  179. Label l; {
  180.     lastInstr        = getMem(3);
  181.     instrAt(lastInstr)    = opc;
  182.     cellAt(lastInstr+1) = c;
  183.     labAt(lastInstr+2)    = l;
  184.     if (l<0)
  185.     internal("bad Label");
  186. }
  187.  
  188. /* --------------------------------------------------------------------------
  189.  * Main low level assembler control: (includes label assignment and fixup)
  190.  *
  191.  * Labels are used as a simple form of continuation during the code gen:
  192.  *  RUNON    => produce code which does not make jump at end of construction
  193.  *  UPDRET   => produce code which performs UPDATE 0, RETURN at end
  194.  *  VALRET   => produce code which performs RETURN at end
  195.  *  other(d) => produce code which branches to label d at end
  196.  * ------------------------------------------------------------------------*/
  197.  
  198. static    Label          nextLab;           /* next label number to allocate    */
  199. #define SHOULDNTFAIL  (-1)
  200. #define RUNON          (-2)
  201. #define UPDRET          (-3)
  202. #define VALRET          (-4)
  203. static    Addr          fixups[NUM_FIXUPS]; /* fixup table maps Label -> Addr*/
  204. #define atLabel(n)    fixups[n] = getMem(0)
  205. #define endLabel(d,l) if (d==RUNON) atLabel(l)
  206. #define fix(a)          addrAt(a) = fixups[labAt(a)]
  207.  
  208. static Void local asSTART() {           /* initialise assembler           */
  209.     fixups[0]  = noMatch;
  210.     nextLab    = 1;
  211.     startInstr = getMem(0);
  212.     lastInstr  = startInstr-1;
  213. }
  214.  
  215. static Label local newLabel(d)           /* allocate new label           */
  216. Label d; {
  217.     if (d==RUNON) {
  218.     if (nextLab>=NUM_FIXUPS) {
  219.         ERROR(0) "Compiled code too complex"
  220.         EEND;
  221.     }
  222.     return nextLab++;
  223.     }
  224.     return d;
  225. }
  226.  
  227. static Void local asEND() {           /* Fix addresses in assembled code  */
  228.     Addr pc = startInstr;
  229.  
  230.     while (pc<=lastInstr)
  231.     switch (instrAt(pc)) {
  232.         case iEVAL     :           /* opcodes taking no arguments       */
  233.         case iFAIL     :
  234.         case iRETURN : pc++;
  235.                break;
  236.  
  237.         case iGOTO     : fix(pc+1);  /* opcodes taking one argument       */
  238.         case iSETSTK :
  239.         case iALLOC  :
  240.         case iSLIDE  :
  241.         case iROOT     :
  242.             case iDICT   :
  243.         case iLOAD     :
  244.         case iCELL     :
  245.         case iCHAR     :
  246.         case iINT     :
  247.         case iFLOAT  :
  248.         case iSTRING :
  249.         case iMKAP     :
  250.         case iUPDATE :
  251.         case iUPDAP  : pc+=2;
  252.                break;
  253.  
  254.         case iINTGE  :           /* opcodes taking two arguments       */
  255.         case iINTEQ  :
  256.         case iINTDV     :
  257.         case iTEST     : fix(pc+2);
  258.                pc+=3;
  259.                break;
  260.  
  261.         default     : internal("fixAddrs");
  262.     }
  263. }
  264.  
  265. /* --------------------------------------------------------------------------
  266.  * Assembler Opcodes: (includes simple peephole optimisations)
  267.  * ------------------------------------------------------------------------*/
  268.  
  269. #define asINTEGER(n) instrInt(iINT,n)
  270. #define asFLOAT(fl)  instrFloat(iFLOAT,fl)
  271. #define asSTRING(t)  instrText(iSTRING,t)
  272. #define asCHAR(n)    instrInt(iCHAR,n)
  273. #define asLOAD(n)    instrInt(iLOAD,n)
  274. #define asALLOC(n)   instrInt(iALLOC,n)
  275. #define asROOT(n)    instrInt(iROOT,n)
  276. #define asSETSTK(n)  instrInt(iSETSTK,n)
  277. #define asEVAL()     instrNone(iEVAL)
  278. #define asRETURN()   instrNone(iRETURN)
  279. #define asCELL(c)    instrCell(iCELL,c)
  280. #define asTEST(c,l)  instrCellLab(iTEST,c,l)
  281. #define asINTGE(n,l) instrIntLab(iINTGE,n,l)
  282. #define asINTEQ(n,l) instrIntLab(iINTEQ,n,l)
  283. #define asINTDV(n,l) instrIntLab(iINTDV,n,l)
  284. #define asFAIL()     instrNone(iFAIL)
  285.  
  286. static Void local asDICT(n)        /* pick element of dictionary       */
  287. Int n; {
  288. /* Sadly, the following optimisation cannot be used unless CELL references
  289.  * in compiled code are garbage collected (and possibly modified when cell  
  290.  * indirections are found).
  291.  *
  292.  *    if (instrAt(lastInstr)==iCELL)
  293.  *    -- Peephole optimisation: CELL {dict m};DICT n ==> CELL dict(m+n)
  294.  *    if (whatIs(cellAt(lastInstr+1))==DICTCELL)
  295.  *        cellAt(lastInstr+1) = dict(dictOf(cellAt(lastInstr+1))+n);
  296.  *    else
  297.  *        internal("asDICT");
  298.  *    else  ...
  299.  */
  300.     if (n!=0)                /* optimisation:DICT 0 has no use  */
  301.     instrInt(iDICT,n);        /* for std dictionary construction */
  302. }
  303.  
  304. static Void local asSLIDE(n)        /* Slide results down stack       */
  305. Int n; {
  306.     if (instrAt(lastInstr)==iSLIDE)    /* Peephole optimisation:       */
  307.     intAt(lastInstr+1)+=n;        /* SLIDE n;SLIDE m ===> SLIDE (n+m)*/
  308.     else
  309.     instrInt(iSLIDE,n);
  310. }
  311.  
  312. static Void local asMKAP(n)        /* Make application nodes ...       */
  313. Int n; {
  314.     if (instrAt(lastInstr)==iMKAP)    /* Peephole optimisation:       */
  315.     intAt(lastInstr+1)+=n;        /* MKAP n; MKAP m  ===> MKAP (n+m) */
  316.     else
  317.     instrInt(iMKAP,n);
  318. }
  319.  
  320. static Void local asUPDATE(n)        /* Update node ...           */
  321. Int n; {
  322.     if (instrAt(lastInstr)==iMKAP) {    /* Peephole optimisations:       */
  323.     if (intAt(lastInstr+1)>1) {    /* MKAP (n+1); UPDATE p           */
  324.         intAt(lastInstr+1)--;    /*          ===> MKAP n; UPDAP p */
  325.         instrInt(iUPDAP,n);
  326.     }
  327.     else {
  328.         instrAt(lastInstr) = iUPDAP;
  329.         intAt(lastInstr+1) = n;    /* MKAP 1; UPDATE p ===> UPDAP p   */
  330.     }
  331.     }
  332.     else
  333.     instrInt(iUPDATE,n);
  334. }
  335.  
  336. static Void local asGOTO(l)        /* End evaluation of expr in manner*/
  337. Label l; {                /* indicated by label l           */
  338.     switch (l) {
  339.     case UPDRET : asUPDATE(0);
  340.     case VALRET : asRETURN();
  341.     case RUNON  : break;
  342.     default     : instrLab(iGOTO,l);
  343.               break;
  344.     }
  345. }
  346.  
  347. /* --------------------------------------------------------------------------
  348.  * Dissassembler:
  349.  * ------------------------------------------------------------------------*/
  350.  
  351. #ifdef DEBUG_CODE
  352. #define printAddr(a) printf("0x%04X",a)/* printable representation of Addr */
  353.  
  354. static Void local dissassemble(pc,end) /* print dissassembly of code       */
  355. Addr pc;
  356. Addr end; {
  357.     while (pc<=end) {
  358.     printAddr(pc);
  359.     printf("\t");
  360.     switch (instrAt(pc)) {
  361.         case iLOAD     : pc = dissInt(pc,"LOAD");     break;
  362.         case iCELL     : pc = dissCell(pc,"CELL");     break;
  363.         case iCHAR     : pc = dissInt(pc,"CHAR");     break;
  364.         case iINT     : pc = dissInt(pc,"INT");     break;
  365.         case iFLOAT  : pc = dissFloat(pc,"FLOAT");   break;
  366.         case iSTRING : pc = dissText(pc,"STRING");     break;
  367.         case iMKAP     : pc = dissInt(pc,"MKAP");     break;
  368.         case iUPDATE : pc = dissInt(pc,"UPDATE");     break;
  369.         case iUPDAP  : pc = dissInt(pc,"UPDAP");     break;
  370.         case iEVAL     : pc = dissNone(pc,"EVAL");     break;
  371.         case iRETURN : pc = dissNone(pc,"RETURN");     break;
  372.         case iINTGE  : pc = dissIntAddr(pc,"INTGE"); break;
  373.         case iINTEQ  : pc = dissIntAddr(pc,"INTEQ"); break;
  374.         case iINTDV  : pc = dissIntAddr(pc,"INTDV"); break;
  375.         case iTEST     : pc = dissCellAddr(pc,"TEST"); break;
  376.         case iGOTO     : pc = dissAddr(pc,"GOTO");     break;
  377.         case iSETSTK : pc = dissInt(pc,"SETSTK");     break;
  378.         case iALLOC  : pc = dissInt(pc,"ALLOC");     break;
  379.         case iSLIDE  : pc = dissInt(pc,"SLIDE");     break;
  380.         case iROOT     : pc = dissInt(pc,"ROOT");     break;
  381.             case iDICT   : pc = dissInt(pc,"DICT");      break;
  382.         case iFAIL     : pc = dissNone(pc,"FAIL");     break;
  383.         default     : internal("unknown instruction");
  384.     }
  385.     }
  386. }
  387.  
  388. static Void local printCell(c)           /* printable representation of Cell */
  389. Cell c; {
  390.     if (isName(c))
  391.     printf("%s",textToStr(name(c).text));
  392.     else
  393.     printf("$%d",c);
  394. }
  395.  
  396. static Addr local dissNone(pc,s)       /* dissassemble instr no args       */
  397. Addr   pc;
  398. String s; {
  399.     printf("%s\n",s);
  400.     return pc+1;
  401. }
  402.  
  403. static Addr local dissInt(pc,s)        /* dissassemble instr with Int arg  */
  404. Addr   pc;
  405. String s; {
  406.     printf("%s\t%d\n",s,intAt(pc+1));
  407.     return pc+2;
  408. }
  409.  
  410. static Addr local dissFloat(pc,s)      /* dissassemble instr with Float arg*/
  411. Addr   pc;
  412. String s; {
  413.     printf("%s\t%s\n",s,floatToString(floatAt(pc+1)));
  414.     return pc+2;
  415. }
  416.  
  417. static Addr local dissCell(pc,s)       /* dissassemble instr with Cell arg */
  418. Addr   pc;
  419. String s; {
  420.     printf("%s\t",s);
  421.     printCell(cellAt(pc+1));
  422.     printf("\n");
  423.     return pc+2;
  424. }
  425.  
  426. static Addr local dissText(pc,s)       /* dissassemble instr with Text arg */
  427. Addr   pc;
  428. String s; {
  429.     printf("%s\t%s\n",s,textToStr(textAt(pc+1)));
  430.     return pc+2;
  431. }
  432.  
  433. static Addr local dissAddr(pc,s)       /* dissassemble instr with Addr arg */
  434. Addr   pc;
  435. String s; {
  436.     printf("%s\t",s);
  437.     printAddr(addrAt(pc+1));
  438.     printf("\n");
  439.     return pc+2;
  440. }
  441.  
  442. static Addr local dissIntAddr(pc,s)    /* dissassemble instr with Int/Addr */
  443. Addr   pc;
  444. String s; {
  445.     printf("%s\t%d\t",s,intAt(pc+1));
  446.     printAddr(addrAt(pc+2));
  447.     printf("\n");
  448.     return pc+3;
  449. }
  450.  
  451. static Addr local dissCellAddr(pc,s)   /* dissassemble instr with Cell/Addr*/
  452. Addr   pc;
  453. String s; {
  454.     printf("%s\t",s);
  455.     printCell(cellAt(pc+1));
  456.     printf("\t");
  457.     printAddr(addrAt(pc+2));
  458.     printf("\n");
  459.     return pc+3;
  460. }
  461. #endif
  462.  
  463. /* --------------------------------------------------------------------------
  464.  * Compile expression to code which will build expression without any
  465.  * evaluation.
  466.  * ------------------------------------------------------------------------*/
  467.  
  468. static Void local build(e,s)           /* Generate code which will build an*/
  469. Cell e;                    /* instance of given expression but */
  470. Int  s; {                   /* perform no evaluation        */
  471.     Int n;
  472.  
  473.     switch (whatIs(e)) {
  474.  
  475.     case LETREC    : n = buildLoc(fst(snd(e)),s);
  476.                  build(snd(snd(e)),s+n);
  477.                  asSLIDE(n);
  478.                  break;
  479.  
  480.     case FATBAR    : build(snd(snd(e)),s);
  481.                  build(fst(snd(e)),s+1);
  482.                  asCELL(nameFatbar);
  483.                  asMKAP(2);
  484.                  break;
  485.  
  486.     case COND      : build(thd3(snd(e)),s);
  487.                  build(snd3(snd(e)),s+1);
  488.                  build(fst3(snd(e)),s+2);
  489.                  asCELL(nameIf);
  490.                    asMKAP(3);
  491.                    break;
  492.  
  493.     case GUARDED   : buildGuards(snd(e),s);
  494.                  break;
  495.  
  496.     case AP        : /*build(snd(e),s);
  497.                  build(fst(e),s+1);
  498.                  asMKAP(1);*/
  499.                  buildAp(e,s,SHOULDNTFAIL,FALSE);
  500.                  break;
  501.  
  502.     case UNIT      :
  503.     case TUPLE     :
  504.     case NAME      : asCELL(e);
  505.              break;
  506.  
  507.     case DICTCELL  : asCELL(dict(dictOf(e)));    /* see comments for*/
  508.              break;                /* DICTCELL in make*/
  509.                             /* function below  */
  510.     case INTCELL   : asINTEGER(intOf(e));
  511.              break;
  512.  
  513.         case FLOATCELL : asFLOAT(floatOf(e));
  514.              break;
  515.  
  516.     case STRCELL   : asSTRING(textOf(e));
  517.              break;
  518.  
  519.     case CHARCELL  : asCHAR(charOf(e));
  520.              break;
  521.  
  522.     case OFFSET    : asLOAD(offsetOf(e));
  523.                  break;
  524.  
  525.     default        : internal("build");
  526.     }
  527. }
  528.  
  529. static Void local buildGuards(gs,s)    /* Generate code to compile list    */
  530. List gs;                   /* of guards to a conditional expr  */
  531. Int  s; {                   /* without evaluation           */
  532.     if (isNull(gs)) {
  533.     asCELL(nameFail);
  534.     }
  535.     else {
  536.     buildGuards(tl(gs),s);
  537.     build(snd(hd(gs)),s+1);
  538.     build(fst(hd(gs)),s+2);
  539.     asCELL(nameIf);
  540.     asMKAP(3);
  541.     }
  542. }
  543.  
  544. static Int local buildLoc(vs,s)        /* Generate code to build local var */
  545. List vs;                   /* bindings on stack,  with no eval */
  546. Int  s; {
  547.     Int n = length(vs);
  548.     Int i;
  549.  
  550.     asALLOC(n);
  551.     for (i=1; i<=n; i++) {
  552.      build(hd(vs),s+n);
  553.      asUPDATE(s+i);
  554.      vs = tl(vs);
  555.     }
  556.     return n;
  557. }
  558.  
  559. /* --------------------------------------------------------------------------
  560.  * Compile expression to code which will build expression evaluating guards
  561.  * and testing cases to avoid building complete graph.
  562.  * ------------------------------------------------------------------------*/
  563.  
  564. #define makeTests(ct,tests,s,f,d)      {   Label l1 = newLabel(d);        \
  565.                        List  xs = tests;            \
  566.                        while (nonNull(tl(xs))) {        \
  567.                            Label l2 = newLabel(RUNON);  \
  568.                            ct(hd(xs),s,f,l2,l1);        \
  569.                            atLabel(l2);            \
  570.                            xs = tl(xs);            \
  571.                        }                    \
  572.                        ct(hd(xs),s,f,f,d);            \
  573.                        endLabel(d,l1);            \
  574.                        }
  575.  
  576. static Void local make(e,s,f,d)        /* Construct code to build e, given */
  577. Cell  e;                   /* s arguments on stack, and branch */
  578. Int   s;                   /* to f on failure, d on completion */
  579. Label f;
  580. Label d; {
  581.     switch (whatIs(e)) {
  582.  
  583.     case LETREC    : {   Int n = buildLoc(fst(snd(e)),s);
  584.                  make(snd(snd(e)),s+n,f,RUNON);
  585.                  asSLIDE(n);
  586.                  asGOTO(d);
  587.                  }
  588.                  break;
  589.  
  590.     case FATBAR    : {   Label l1 = newLabel(RUNON);
  591.                  Label l2 = newLabel(d);
  592.  
  593.                  make(fst(snd(e)),s,l1,l2);
  594.  
  595.                  atLabel(l1);
  596.                  asSETSTK(s);
  597.                  make(snd(snd(e)),s,f,l2);
  598.  
  599.                  endLabel(d,l2);
  600.                  }
  601.                  break;
  602.  
  603.     case COND      : makeCond(fst3(snd(e)),
  604.                   snd3(snd(e)),
  605.                   thd3(snd(e)),s,f,d);
  606.                  break;
  607.  
  608.     case CASE      : make(fst(snd(e)),s,SHOULDNTFAIL,RUNON);
  609.                  asEVAL();
  610.                  makeTests(testCase,snd(snd(e)),s,f,d);
  611.                  break;
  612.  
  613.     case GUARDED   : makeTests(testGuard,snd(e),s,f,d);
  614.                  break;
  615.  
  616.     case AP        : if (andorOptimise) {
  617.                  Cell h = getHead(e);
  618.                  if (h==nameAnd && argCount==2) {
  619.                  /* x && y ==> if x then y else False       */
  620.                  makeCond(arg(fun(e)),arg(e),nameFalse,s,f,d);
  621.                  break;
  622.                  }
  623.                  else if (h==nameOr && argCount==2) {
  624.                  /* x || y ==> if x then True else y       */
  625.                  makeCond(arg(fun(e)),nameTrue,arg(e),s,f,d);
  626.                  break;
  627.                  }
  628.              }
  629.              /*build(snd(e),s);
  630.                          make(fst(e),s+1,f,RUNON);
  631.                          asMKAP(1);*/
  632.                          buildAp(e,s,f,TRUE);
  633.                          asGOTO(d);
  634.                          break;
  635.  
  636.     case UNIT      :
  637.     case TUPLE     :
  638.     case NAME      : asCELL(e);
  639.                  asGOTO(d);
  640.                  break;
  641.  
  642.     /* for dict cells, ensure that CELL referred to in the code is the */
  643.     /* dictionary cell at the head of the dictionary; not just a copy  */
  644.  
  645.     case DICTCELL  : asCELL(dict(dictOf(e)));
  646.                  asGOTO(d);
  647.                  break;
  648.  
  649.     case INTCELL   : asINTEGER(intOf(e));
  650.                  asGOTO(d);
  651.                  break;
  652.  
  653.         case FLOATCELL : asFLOAT(floatOf(e));
  654.                  asGOTO(d);
  655.              break;
  656.  
  657.     case STRCELL   : asSTRING(textOf(e));
  658.                  asGOTO(d);
  659.                  break;
  660.  
  661.     case CHARCELL  : asCHAR(charOf(e));
  662.                  asGOTO(d);
  663.                  break;
  664.  
  665.     case OFFSET    : asLOAD(offsetOf(e));
  666.                  asGOTO(d);
  667.                  break;
  668.  
  669.     default        : internal("make");
  670.     }
  671. }
  672.  
  673. static Void local makeCond(i,t,e,s,f,d)    /* Build code for conditional       */
  674. Cell  i,t,e;
  675. Int   s;
  676. Label f;
  677. Label d; {
  678.     Label l1 = newLabel(RUNON);
  679.     Label l2 = newLabel(d);
  680.  
  681.     make(i,s,f,RUNON);
  682.     asEVAL();
  683.  
  684.     asTEST(nameTrue,l1);
  685.     make(t,s,f,l2);
  686.  
  687.     atLabel(l1);
  688.     make(e,s,f,l2);
  689.  
  690.     endLabel(d,l2);
  691. }
  692.  
  693. static Void local testGuard(g,s,f,cf,d) /* Produce code for guard       */
  694. Pair  g;
  695. Int   s;
  696. Label f;
  697. Label cf;
  698. Label d; {
  699.     make(fst(g),s,SHOULDNTFAIL,RUNON);
  700.     asEVAL();
  701.     asTEST(nameTrue,cf);
  702.     make(snd(g),s,f,d);
  703. }
  704.  
  705. static Void local testCase(c,s,f,cf,d)  /* Produce code for guard       */
  706. Pair  c;
  707. Int   s;                /* labels determine where to go if:*/
  708. Label f;                /* match succeeds, but rest fails  */
  709. Label cf;                /* this match fails           */
  710. Label d; {
  711.     switch (whatIs(fst(c))) {
  712.     case INTCELL : asINTEQ(intOf(fst(c)),cf);
  713.                break;
  714.     case ADDPAT  : asINTGE(intValOf(fst(c)),cf);
  715.                break;
  716.     case MULPAT  : asINTDV(intValOf(fst(c)),cf);
  717.                break;
  718.     default      : asTEST(fst(c),cf);
  719.                break;
  720.     }
  721.     make(snd(c),s+discrArity(fst(c)),f,d);
  722. }
  723.  
  724. /* --------------------------------------------------------------------------
  725.  * We frequently encounter functions which call themselves recursively with
  726.  * a number of initial arguments preserved:
  727.  * e.g.  (map f) []    = []
  728.  *     (map f) (x:xs) = f x : (map f) xs
  729.  * Lambda lifting, in particular, is likely to introduce such functions.
  730.  * Rather than reconstructing a new instance of the recursive function and
  731.  * it's arguments, we can extract the relevant portion of the root of the
  732.  * current redex.
  733.  *
  734.  * The following functions implement this optimisation.
  735.  * ------------------------------------------------------------------------*/
  736.  
  737. static Int  nonRoots;               /* #args which can't get from root  */
  738. static Int  rootPortion;           /* portion of root used ...       */
  739. static Name definingName;           /* name of func being defined,if any*/
  740. static Int  definingArity;           /* arity of definingName        */
  741.  
  742. static Void local analyseAp(e)           /* Determine if any portion of an   */
  743. Cell e; {                   /* application can be built using a */
  744.     if (isAp(e)) {               /* portion of the root           */
  745.     analyseAp(fun(e));
  746.     if (nonRoots==0 && rootPortion>1
  747.             && isOffset(arg(e))
  748.             && offsetOf(arg(e))==rootPortion-1)
  749.         rootPortion--;
  750.     else
  751.         nonRoots++;
  752.     }
  753.     else if (e==definingName)
  754.     rootPortion = definingArity+1;
  755.     else
  756.     rootPortion = 0;
  757. }
  758.  
  759. static Void local buildAp(e,s,f,str)   /* Build application, making use of */
  760. Cell  e;                   /* root optimisation if poss.       */
  761. Int   s;
  762. Label f;
  763. Bool  str; {
  764.     Int nr, rp, i;
  765.  
  766.     nonRoots = 0;
  767.     analyseAp(e);
  768.     nr = nonRoots;
  769.     rp = rootPortion;
  770.  
  771.     for (i=0; i<nr; ++i) {
  772.     build(arg(e),s+i);
  773.     e = fun(e);
  774.     }
  775.  
  776.     if (isSelect(e)) {
  777.         if (selectOf(e)>0)
  778.         asDICT(selectOf(e));
  779.     }
  780.     else {
  781.     if (isName(e) && name(e).defn==MFUN) {
  782.         asDICT(name(e).number);
  783.         nr--;    /* AP node for member function need never be built */
  784.     }
  785.     else {
  786.         if (0<rp && rp<=definingArity)
  787.         asROOT(rp-1);
  788.         else
  789.         if (str)
  790.             make(e,s+nr,f,RUNON);
  791.         else
  792.             build(e,s+nr);
  793.     }
  794.  
  795.     if (nr>0)
  796.         asMKAP(nr);
  797.     }
  798. }
  799.  
  800. /* --------------------------------------------------------------------------
  801.  * Code generator entry point:
  802.  * ------------------------------------------------------------------------*/
  803.  
  804. Addr codeGen(n,arity,e)            /* Generate code for expression e,  */
  805. Name n;                    /* treating return value of CAFs    */
  806. Int  arity;                   /* differently to functs with args  */
  807. Cell e; {
  808.     definingName  = n;
  809.     definingArity = arity;
  810.     asSTART();
  811. #ifdef DEBUG_CODE
  812. printf("------------------\n");
  813. if (nonNull(n)) printf("name=%s\n",textToStr(name(n).text));
  814. printf("Arity   = %d\n",arity);
  815. printf("codeGen = "); printExp(stdout,e); putchar('\n');
  816. #endif
  817.     make(e,arity,noMatch,(arity>0 ? UPDRET : VALRET));
  818.     asEND();
  819. #ifdef DEBUG_CODE
  820. dissassemble(startInstr,lastInstr);
  821. printf("------------------\n");
  822. #endif
  823.     return startInstr;
  824. }
  825.  
  826. /* --------------------------------------------------------------------------
  827.  * Evaluator:
  828.  * ------------------------------------------------------------------------*/
  829.  
  830. Int   whnfArgs;                   /* number of arguments of whnf term */
  831. Cell  whnfHead;                   /* head cell of term in whnf       */
  832. Int   whnfInt;                   /* value of INTCELL (in whnf)       */
  833. Float whnfFloat;               /* value of FLOATCELL (in whnf)     */
  834. Long  numReductions;               /* number of reductions counted       */
  835.  
  836. static Cell    errorRedex;           /* irreducible error expression       */
  837. static jmp_buf *evalError = 0;           /* jump buffer for eval errors       */
  838.  
  839. #ifdef DEBUG_RUN
  840. static evalCnt=0;
  841. #endif
  842.  
  843. Void eval(n)                   /* Graph reduction evaluator    */
  844. Cell n; {
  845.     StackPtr base = sp;
  846.     Int      ar;
  847.  
  848. #ifdef DEBUG_RUN
  849.     Int keepEvalCnt = evalCnt++;
  850.     printf("%-5d Eval: ",keepEvalCnt);
  851.     printExp(stdout,n);
  852.     putchar('\n');
  853. #endif
  854. unw:switch (whatIs(n)) {           /* unwind spine of application  */
  855.  
  856.     case AP        : push(n);
  857.              n = fun(n);
  858.              goto unw;
  859.  
  860.     case INDIRECT  : n = arg(n);
  861.              allowBreak();
  862.              goto unw;
  863.  
  864.     case NAME      : ar = name(n).arity;
  865. #ifdef DEBUG_RUN
  866.     printf("Reducing %s:\n",textToStr(name(n).text));
  867. #endif
  868.              if (name(n).defn!=CFUN && sp-base>=ar) {
  869.                  allowBreak();
  870.                  if (ar>0) {             /* fn with args*/
  871.                  StackPtr root;
  872.  
  873.                  push(NIL);            /* rearrange   */
  874.                  root = sp;
  875.                  do {
  876.                      stack(root) = arg(stack(root-1));
  877.                      --root;
  878.                  } while (--ar>0);
  879.  
  880.                  if (name(n).primDef)        /* reduce       */
  881.                      (*name(n).primDef)(root);
  882.                  else
  883.                      run(name(n).code,root);
  884.  
  885.                  numReductions++;
  886.  
  887.                  sp = root;            /* continue... */
  888.                  n  = pop();
  889.                  }
  890.                  else {                /* CAF       */
  891.                  if (isNull(name(n).defn)) {/* build CAF   */
  892.                      push(n);            /* save CAF    */
  893.  
  894.                      if (name(n).primDef)
  895.                      (*name(n).primDef)(sp);
  896.                      else
  897.                      run(name(n).code,sp);
  898.  
  899.                      numReductions++;
  900.  
  901.                      name(n).defn = pop();
  902.                      drop();            /* drop CAF    */
  903.                  }
  904.                  n = name(n).defn;        /*already built*/
  905.                  if (sp>base)
  906.                      fun(top()) = n;
  907.                  }
  908.                  goto unw;
  909.              }
  910.              break;
  911.  
  912.     case INTCELL   : whnfInt = intOf(n);
  913.              break;
  914.  
  915.         case FLOATCELL : whnfFloat = floatOf(n);
  916.              break;
  917.  
  918.     case STRCELL   : evalString(n);
  919.              goto unw;
  920.  
  921.     case FILECELL  : evalFile(n);
  922.              goto unw;
  923.     }
  924.  
  925.     whnfHead = n;               /* rearrange components of term on  */
  926.     whnfArgs = sp - base;           /* stack, now in whnf ...       */
  927.     for (ar=whnfArgs; ar>0; ar--) {
  928.     fun(stack(base+ar)) = n;
  929.     n            = stack(base+ar);
  930.     stack(base+ar)        = arg(n);
  931.     }
  932. #ifdef DEBUG_RUN
  933.     printf("%-5d Whnf: ",keepEvalCnt);
  934.     printExp(stdout,n);
  935.     putchar('\n');
  936. #endif
  937. }
  938.  
  939. Void unwind(n)                   /* unwind spine of application;       */
  940. Cell n; {                   /* like eval except that we always  */
  941.     whnfArgs = 0;               /* treat the expression n as if it  */
  942.                        /* were already in whnf.        */
  943. unw:switch (whatIs(n)) {
  944.     case AP        : push(arg(n));
  945.              whnfArgs++;
  946.              n = fun(n);
  947.              goto unw;
  948.  
  949.     case INDIRECT  : n = arg(n);
  950.              allowBreak();
  951.              goto unw;
  952.  
  953.     case INTCELL   : whnfInt = intOf(n);
  954.              break;
  955.  
  956.         case FLOATCELL : whnfFloat = floatOf(n);
  957.              break;
  958.  
  959.     case STRCELL   : evalString(n);
  960.              goto unw;
  961.     }
  962.     whnfHead = n;
  963. }
  964.  
  965. static Void local evalString(n)        /* expand STRCELL at node n       */
  966. Cell n; {
  967.     Text t = textOf(n);
  968.     Int  c = textToStr(t)[0];
  969.     if (c==0) {
  970.     fst(n) = INDIRECT;
  971.     snd(n) = nameNil;
  972.     return;
  973.     }
  974.     else if (c=='\\') {
  975.     c = textToStr(++t)[0];
  976.         if (c!='\\')
  977.         c = 0;
  978.     }
  979.     fst(n) = consChar(c);
  980.     snd(n) = mkStr(++t);
  981. }
  982.  
  983. static Void local run(pc,root)           /* execute code beginning at given  */
  984. Addr     pc;                   /* address with local stack starting*/
  985. StackPtr root; {               /* at given root offset           */
  986.     Cell t;
  987.     Int  i;
  988.  
  989.     for (;;)
  990.     switch (instrAt(pc)) {
  991.  
  992.         case iLOAD     : push(stack(root+intAt(pc+1)));/* load from stack*/
  993.                pc+=2;
  994.                continue;
  995.  
  996.         case iCELL     : push(cellAt(pc+1));         /* load const Cell*/
  997.                pc+=2;
  998.                continue;
  999.  
  1000.         case iCHAR     : push(mkChar(intAt(pc+1)));     /* load char const*/
  1001.                pc+=2;
  1002.                continue;
  1003.  
  1004.         case iINT     : push(mkInt(intAt(pc+1)));     /* load int const */
  1005.                pc+=2;
  1006.                continue;
  1007.  
  1008.         case iFLOAT  : push(mkFloat(floatAt(pc+1))); /* load float cnst*/
  1009.                pc+=2;
  1010.                continue;
  1011.  
  1012.         case iSTRING : push(mkStr(textAt(pc+1)));     /* load str const */
  1013.                pc+=2;
  1014.                continue;
  1015.  
  1016.         case iMKAP     : t=pushed(0);          /* make AP nodes  */
  1017.                for (i=intAt(pc+1); i>0; --i) {
  1018.                    drop();
  1019.                    t=ap(t,pushed(0));
  1020.                }
  1021.                pushed(0)=t;
  1022.                pc+=2;
  1023.                continue;
  1024.  
  1025.         case iUPDATE : t=stack(root+intAt(pc+1));     /* update cell ...*/
  1026.                fst(t) = INDIRECT;
  1027.                snd(t) = pop();
  1028.                pc+=2;
  1029.                continue;
  1030.  
  1031.         case iUPDAP  : t=stack(root+intAt(pc+1));     /* update AP node */
  1032.                fst(t) = pop();
  1033.                snd(t) = pop();
  1034.                pc+=2;
  1035.                continue;
  1036.  
  1037.         case iEVAL     : eval(pop());          /* evaluate top() */
  1038.                pc++;
  1039.                continue;
  1040.  
  1041.         case iRETURN : return;             /* terminate       */
  1042.  
  1043.         case iINTGE  : if (whnfInt>=intAt(pc+1)) {     /* test integer >=*/
  1044.                    push(mkInt(whnfInt-intAt(pc+1)));
  1045.                    pc+=3;
  1046.                }
  1047.                else
  1048.                    pc=addrAt(pc+2);
  1049.                continue;
  1050.  
  1051.         case iINTEQ  : if (whnfInt==intAt(pc+1))     /* test integer ==*/
  1052.                    pc+=3;
  1053.                else
  1054.                    pc=addrAt(pc+2);
  1055.                continue;
  1056.  
  1057.         case iINTDV  : if (whnfInt>=0 &&         /* test for mult  */
  1058.                                (whnfInt%intAt(pc+1)==0)) {
  1059.                    push(mkInt(whnfInt/intAt(pc+1)));
  1060.                    pc+=3;
  1061.                }
  1062.                else
  1063.                    pc=addrAt(pc+2);
  1064.                continue;
  1065.  
  1066.         case iTEST     : if (whnfHead==cellAt(pc+1))     /* test for cell  */
  1067.                    pc+=3;
  1068.                else
  1069.                    pc=addrAt(pc+2);
  1070.                continue;
  1071.  
  1072.         case iGOTO     : pc=addrAt(pc+1);         /* goto label       */
  1073.                continue;
  1074.  
  1075.         case iSETSTK : sp=root+intAt(pc+1);      /* set stack ptr  */
  1076.                pc+=2;
  1077.                continue;
  1078.  
  1079.         case iALLOC  : for (i=intAt(pc+1); i>0; --i) /* alloc loc vars */
  1080.                    push(ap(NIL,NIL));
  1081.                pc+=2;
  1082.                continue;
  1083.  
  1084.             case iDICT   : top() = dict(dictOf(top())+intAt(pc+1));
  1085.                            pc+=2;                        /* dict lookup    */
  1086.                            continue;
  1087.  
  1088.         case iROOT     : t=stack(root);         /* partial root   */
  1089.                while (fst(t)==INDIRECT) {
  1090.                    allowBreak();
  1091.                    t = arg(t);
  1092.                }
  1093.                for (i=intAt(pc+1); i>0; --i) {
  1094.                    t = fun(t);
  1095.                    while (fst(t)==INDIRECT) {
  1096.                    allowBreak();
  1097.                    t = arg(t);
  1098.                    }
  1099.                }
  1100.                pc+=2;
  1101.                push(t);
  1102.                continue;
  1103.  
  1104.         case iSLIDE  : pushed(intAt(pc+1)) = top();  /* remove loc vars*/
  1105.                sp-=intAt(pc+1);
  1106.                pc+=2;
  1107.                continue;
  1108.  
  1109.         case iFAIL     : evalFails(root);         /* cannot reduce  */
  1110.                break;
  1111.  
  1112.         default     : internal("illegal instruction");
  1113.                break;
  1114.     }
  1115. }
  1116.  
  1117. Cell evalWithNoError(e)            /* Evaluate expression, returning   */
  1118. Cell e; {                   /* NIL if successful, irreducible   */
  1119.     Cell badRedex;               /* expression if not...           */
  1120.     jmp_buf *oldCatch = evalError;
  1121.  
  1122. #if JMPBUF_ARRAY
  1123.     jmp_buf catch[1];
  1124.     evalError = catch;
  1125.     if (setjmp(catch[0])==0) {
  1126.     eval(e);
  1127.     badRedex = NIL;
  1128.     }
  1129.     else
  1130.     badRedex = errorRedex;
  1131. #else
  1132.     jmp_buf catch;
  1133.     evalError = &catch;
  1134.     if (setjmp(catch)==0) {
  1135.         eval(e); 
  1136.     badRedex = NIL;
  1137.     }
  1138.     else
  1139.         badRedex = errorRedex;
  1140. #endif
  1141.  
  1142.     evalError = oldCatch;
  1143.     return badRedex;
  1144. }
  1145.  
  1146. Void evalFails(root)            /* Eval of current redex fails       */
  1147. StackPtr root; {
  1148.     errorRedex = stack(root);        /* get error & bypass indirections */
  1149.     while (isPair(errorRedex) && fst(errorRedex)==INDIRECT)
  1150.     errorRedex = snd(errorRedex);
  1151.  
  1152.     if (failOnError)
  1153.     abandon("evaluation",errorRedex);
  1154.     else if (evalError)
  1155.     longjmp(*evalError,1);
  1156.     else
  1157.     internal("uncaught eval error");
  1158. }
  1159.  
  1160. Cell graphForExp() {            /* Build graph for expression to be*/
  1161.     clearStack();            /* reduced...               */
  1162.     run(inputCode,sp);
  1163.     return pop();
  1164. }
  1165.  
  1166. /* --------------------------------------------------------------------------
  1167.  * Machine control:
  1168.  * ------------------------------------------------------------------------*/
  1169.  
  1170. Void machine(what)
  1171. Int what; {
  1172.     switch (what) {
  1173.     case RESET   : break;
  1174.  
  1175.     case MARK    : break;
  1176.  
  1177.     case INSTALL : machine(RESET);
  1178.                memory  = (Memory)farCalloc(NUM_ADDRS,sizeof(MemCell));
  1179.                if (memory==0)
  1180.                internal("Cannot allocate program memory");
  1181.                instrNone(iFAIL);
  1182.                noMatch = lastInstr;
  1183.                break;
  1184.     }
  1185. }
  1186.  
  1187. /* ------------------------------------------------------------------------*/
  1188.